Internet Info 1994 March

home *** CD-ROM | disk | FTP | other *** search

/ Internet Info 1994 March / Internet Info CD-ROM (Walnut Creek) (March 1994).iso / networking / terms / kermit / b / iktgup.asm < prev next >

Wrap

Assembly Source File | 1992-09-29 | 36.9 KB | 468 lines

*COPY GUPVAR 10000000 * Specific variables 10001000 EVCTR DS F File sequence number TSO 10002000 ICPRGS DS 4F Saved registers for type-out @SC88026 10003000 * 10004000 PPLAREA DS A(0,0,CPECB,PRSPCL,RESULT,0,USERBLK) GUP1.1 10005000 CPECB DS F GETLINE/PUTLINE/PUTGET ECB @TS86001 10006000 RESULT DS A Parse PDL ptr GUP1.1 10007000 USERBLK DS D Parse work area (not used) GUP1.1 10008000 * 10009000 CAMLOC DS 4F Ptrs for locating dataset @SC86299 10010000 CAMOBT DS 4F Ptrs for getting DSCB @SC86299 10011000 CAMVOLS DS 0D,XL265 Storage for volume list @SC86299 10012000 CAMDSCB DS 0F,XL101 Storage for DSCB @SC88014 10013000 ORG CAMDSCB+1 @SC88014 10014000 DS1VOL DS CL6,XL2 Volume serial @SC86299 10015000 DS1CRDT DS 2XL3,3X,XL13 Creation date @SC86299 10016000 DS1RFDT DS XL3,XL4 Reference date @SC86299 10017000 DS1DSO DS XL2 Dataset org @SC86299 10018000 DS1RCF DS X Record format @SC86299 10019000 DS1OPT DS X Error option @SC86299 10020000 DS1BLK DS H Block size @SC86299 10021000 DS1LRC DS H Logical record length @SC86299 10022000 ORG , @SC86299 10023000 DYNPL DS A(0,0,0,0,DYNDSP,0),X'80',AL3(DYNRC) GUP1.1 10024000 DYNRC DS F @SC86299 10025000 DYNDSP DS X @SC86299 10026000 FNAME DS CL130 Buffer for reading TSO 10027000 *COPY GUPSPC 10028000 * External references in TSO GUPI: 10028100 * CLOSE DCB FREEMAIN FREEPOOL GETMAIN IKJCPPL IKJENDP 10028200 * IKJIDENT IKJKEYWD IKJNAME IKJPARM IKJPOSIT IKJSUBF LINK 10028300 * LOCATE OBTAIN OPEN SAVE 10028400 * 10028500 * Specific preliminaries 10029000 &STORDS SETC 'KSTORG' Storage DSECT for Kermit globals @SC89268 10029500 * 10030000 LFID EQU 60 Filespec length GUP1.2 10031000 STKDWDS EQU 511 Requested stack length TSO 10032000 XXBAT EQU X'04' Special flag for batch mode GUP1.1 10033000 KWRKBASE EQU 11 Base register for work area @SC89268 10033300 KSUBBASE EQU 12 Base register for CSECT @SC89268 10033600 * 10034000 IKJCPPL , GUP1.1 10035000 *COPY GUPFIN 10036000 LR 2,15 Save return code GUP1.1 10037000 CLOSE MSGFIL GUP1.1 10038000 LR 15,2 Return code GUP1.1 10039000 *COPY GUPNIT 10040000 * TSO user interface TSO 10041000 * 10042000 LA 4,DYNDSP Set up DYNALC plist GUP1.2 10043000 LA 6,DYNRC GUP1.2 10044000 STM 4,6,DYNPL+16 GUP1.2 10045000 OI DYNPL+24,X'80' Mark end of plist GUP1.2 10046000 * 10047000 TM 0(1),X'80' What kind of plist? GUP1.1 10048000 BZ GUPCP Seems to be CP GUP1.1 10049000 MVC SRCNAM(3*LFID+3),BATDDNS Copy ddnames+mark GUP1.1 10050000 LA 4,XXCOR+XX8+XXBAT Default flags GUP1.1 10051000 L 1,0(1) Ptr to parm string GUP1.1 10052000 LH 2,0(1) Get length GUP1.1 10053000 OPTLP SR 0,0 Mask: zeroes GUP1.1 10054000 CH 2,EH2 Enough for a 'NO'? GUP1.1 10055000 BL OPTZ No GUP1.1 10056000 CLC =C'NO',2(1) Is it? GUP1.1 10057000 BNE OPTYES No, assume positive option GUP1.1 10058000 EH2 EQU *+2,2 GUP1.1 10059000 LA 1,2(1) Yes, it is. Space over the NO GUP1.1 10060000 SH 2,EH2 Cut off the NO GUP1.1 10061000 BCTR 0,0 Mask: ones GUP1.1 10062000 OPTYES SH 2,EH4 See if room for option GUP1.1 10063000 BL OPTZ No, done scan GUP1.1 10064000 CLC =C'MARK=',2(1) GUP1.1 10065000 BNE OPTCK Check flags GUP1.1 10066000 SH 2,EH4 See if mark field available GUP1.1 10067000 BL OPTZ No, done scan GUP1.1 10068000 MVC MRKD,7(1) Copy in case NOSEQ8 GUP1.1 10069000 LA 1,8(1) Space over option GUP1.1 10070000 B OPTLQ GUP1.1 10071000 OPTCK LA 3,XX8 Test for SEQ8 GUP1.1 10072000 CLC =C'SEQ8',2(1) GUP1.1 10073000 BE OPTOK Found it GUP1.1 10074000 LA 3,XXCOR Test for in-storage GUP1.1 10075000 CLC =C'STOR',2(1) GUP1.1 10076000 BNE OPTZ None of these, give up GUP1.1 10077000 OPTOK OR 4,3 Turn flag on GUP1.1 10078000 NR 3,0 GUP1.1 10079000 XR 4,3 Turn off if "NO" GUP1.1 10080000 LA 1,4(1) Advance ptr over option GUP1.1 10081000 OPTLQ LTR 2,2 Any more options? GUP1.1 10082000 BNP OPTZ GUP1.1 10083000 CLI 2(1),C',' Make sure there is a separator GUP1.1 10084000 BNE OPTZ No, give up GUP1.1 10085000 LA 1,1(1) GUP1.1 10086000 BCT 2,OPTLP GUP1.1 10087000 OPTZ STC 4,FLG Save current flags GUP1.1 10088000 OPEN (MSGFIL,OUTPUT) Message data set GUP1.1 10089000 TM MSGFIL+FABOFLGS-FABD,X'10' GUP1.1 10090000 BZ ERREX Oops GUP1.1 10091000 B OPN GUP1.1 10092000 * 10093000 USING CPPL,1 @SC86299 10094000 GUPCP MVI SRCNAM,C' ' GUP1.1 10095000 MVC SRCNAM+1(3*LFID+2),SRCNAM Blank out parm area GUP1.1 10096000 MVI FLG,0 GUP1.1 10097000 L 3,CPPLUPT Fill in parse parameter list GUP1.1 10098000 L 4,CPPLECT GUP1.1 10099000 LA 5,CPECB GUP1.2 10100000 L 6,=V(PRSPCL) GUP1.2 10101000 LA 7,RESULT GUP1.2 10102000 L 8,CPPLCBUF GUP1.2 10103000 LA 9,USERBLK GUP1.2 10104000 STM 3,9,PPLAREA GUP1.1 10105000 DROP 1 GUP1.1 10106000 MVI CPECB,0 GUP1.1 10107000 LINK EP=IKJPARS,MF=(E,PPLAREA) Perform parsing serviceUP1.1 10108000 LTR 15,15 Any good? GUP1.1 10109000 BNZ ERREX No, exit with error GUP1.1 10110000 * Interpret results GUP1.1 10111000 L 8,RESULT Address parsed data GUP1.1 10112000 USING IKJPARMD,8 GUP1.1 10113000 LA 1,PRSSRC -> Base dataset name info GUP1.1 10114000 LA 6,SRCNAM -> Destination field GUP1.1 10115000 BAL 7,MOVDSN Move dataset name GUP1.1 10116000 LA 1,PRSCTL Do update DSN GUP1.1 10117000 LA 6,CTLNAM GUP1.1 10118000 BAL 7,MOVDSN GUP1.1 10119000 LA 1,PRSOUT Do output DSN GUP1.1 10120000 LA 6,OUTNAM GUP1.1 10121000 BAL 7,MOVDSN GUP1.1 10122000 CLI PRSSEQ8+1,1 SEQ8 option set? GUP1.1 10123000 BNE *+8 No GUP1.1 10124000 OI FLG,XX8 Yes, enable flag GUP1.1 10125000 CLI PRSSTOR+1,1 STOR option set? GUP1.1 10126000 BNE *+8 No GUP1.1 10127000 OI FLG,XXCOR Yes, enable flag GUP1.1 10128000 LA 1,PRSMRKV GUP1.1 10129000 LA 6,MRKD GUP1.1 10130000 BAL 7,MOVMEM Move mark, if any GUP1.1 10131000 B OPN Done GUP1.1 10132000 * 10133000 MOVDSN L 2,0(1) --> dataset name GUP1.1 10134000 LH 3,4(1) Length GUP1.1 10135000 BCTR 3,0 GUP1.1 10136000 EX 3,CPYTXT Move dataset name GUP1.1 10137000 LA 6,44(6) Point to member storage GUP1.1 10138000 LA 1,8(1) GUP1.1 10139000 MOVMEM L 2,0(1) Member name GUP1.1 10140000 LTR 2,2 Test for member GUP1.1 10141000 BZR 7 None GUP1.1 10142000 LH 3,4(1) Length GUP1.1 10143000 BCTR 3,0 GUP1.1 10144000 EX 3,CPYTXT Move member name GUP1.1 10145000 BR 7 GUP1.1 10146000 CPYTXT MVC 0(,6),0(2) GUP1.1 10147000 DROP 8 GUP1.1 10148000 * 10149000 WTEXT STM 14,1,ICPRGS Save registers GUP1.1 10150000 TM FLG,XXBAT Batch version? GUP1.1 10151000 BZ WTXCP No, just do a TPUT GUP1.1 10152000 STH 0,MSGFIL+FABLRECL-FABD Save LRECL GUP1.1 10153000 LR 0,1 GUP1.1 10154000 PUT MSGFIL,(0) And write it out GUP1.1 10155000 B WTXRET GUP1.1 10156000 WTXCP SVC 93 GUP1.1 10157000 WTXRET LM 14,1,ICPRGS Restore and return GUP1.1 10158000 BR 15 GUP1.1 10159000 * 10160000 MSGFIL DCB DDNAME=SYSPRINT,MACRF=PM,RECFM=U,BLKSIZE=130,DSORG=PS 10161000 * 10162000 BATDDNS DC CL(LFID)'+SYSUT1' GUP1.2 10163000 DC CL(LFID)'+SYSIN' GUP1.2 10164000 DC CL(LFID)'+SYSUT2' GUP1.2 10165000 DC C' ' Leave sequence field blank GUP1.1 10166000 * 10167000 PRSPCL IKJPARM , GUP1.1 10168000 PRSSRC IKJPOSIT DSNAME,USID,PROMPT='SOURCE DSNAME' GUP1.1 10169000 PRSCTL IKJPOSIT DSNAME,USID,PROMPT='UPDATE DSNAME' GUP1.1 10170000 PRSOUT IKJPOSIT DSNAME,USID,PROMPT='OUTPUT DSNAME' GUP1.1 10171000 PRSSEQ8 IKJKEYWD DEFAULT='SEQ8' GUP1.1 10172000 IKJNAME 'SEQ8' GUP1.1 10173000 IKJNAME 'NOSEQ8' GUP1.1 10174000 PRSSTOR IKJKEYWD DEFAULT='STOR' GUP1.1 10175000 IKJNAME 'STOR' GUP1.1 10176000 IKJNAME 'NOSTOR' GUP1.1 10177000 PRSMARK IKJKEYWD , GUP1.1 10178000 IKJNAME 'MARK',SUBFLD=PRS2MRK GUP1.1 10179000 PRS2MRK IKJSUBF , GUP1.1 10180000 PRSMRKV IKJIDENT 'SEQUENCE MARK',FIRST=ANY,OTHER=ANY,MAXLNTH=3 UP1.1 10181000 IKJENDP , GUP1.1 10182000 GUPI CSECT 10183000 * TSO 10184000 OPNERR LA 1,L'OPNEM TSO 10185000 BAL 0,FILERR TSO 10186000 OPNEM DC C'FILE NOT FOUND: ' TSO 10187000 DSKERR LA 2,8(1) TSO 10188000 LA 1,L'DSKEM TSO 10189000 BAL 0,FILERR TSO 10190000 DSKEM DC C'DISK ERROR ON FILE ' TSO 10191000 * TSO 10192000 FILERR LA 4,FNAME Buffer to use TSO 10193000 LR 5,1 TSO 10194000 MVCL 4,0 Copy message TSO 10195000 LA 3,LFID Length of a name field TSO 10196000 LR 5,3 TSO 10197000 MVCL 4,2 Copy name TSO 10198000 LA 1,FNAME Start of buffer again TSO 10199000 SR 4,1 TSO 10200000 WTEXT (1),(4) TSO 10201000 B ERREX TSO 10202000 *COPY GUPSUB 10203000 TITLE 'DISKIO Routine - performs disk I/O functions' 10204000 * Function selected on entry by R0: 10205000 * 1=> open (in): R1->pattern FDB, R2->name. Returns R0->FAB, R1->FDB 10206000 * 2=> open (out): (same, but no complete FDB if new file) 10207000 * 4=> close file: R1->adr(FAB). 10208000 * 9=> read: R1->FAB. Returns R15=12 if EOF, 0 if ok; R0=# data 10209000 * 10=> write: R1->FAB. Returns R15=13 if disk full, 0 if ok. 10210000 DISKIO ENTER 10211000 USING FABD,3 @SC86295 10212000 SR 4,4 Signal no block assigned @SC86295 10213000 LA 6,FDBTRKAL-FDBD(1) Use pattern TRKAL @SC88026 10214000 ST 6,DYNPL+20 Set up calling sequence GUP1.1 10215000 BCT 0,DSKOPNO @SC86295 10216000 * 10217000 * Open for input file whose name is at (R2), FDB at (R1) 10218000 MVI DYNDSP,X'88' SHR,KEEP @SC86299 10219000 BAL 9,DSKALC Get FAB @SC86295 10220000 BAL 2,DSKLKP Get DSCB @SC86299 10221000 BNZ DSKER1 Not found @SC86295 10222000 BAL 14,DSKVALS @SC86295 10223000 BAL 9,DSKFABS Set up FAB from FDB @SC86299 10224000 CNOP 0,4 @SC86299 10225000 BAL 2,DSKOPT Open and test @SC86299 10226000 OPEN (0,INPUT),MF=L @SC86299 10227000 * 10228000 * Open for output file whose name is at (R2), FDB at (R1) 10229000 DSKOPNO BCT 0,DSKTEST @SC86295 10230000 MVI DYNDSP,X'42' NEW,CATLG @SC86299 10231000 BAL 9,DSKALC Get FAB @SC86295 10232000 BAL 2,DSKLKP Get DSCB @SC86299 10233000 BNZ DSKOPN Not found, just writing new @SC86299 10234000 MVI DYNDSP,X'18' OLD,KEEP @SC86299 10235000 TM DS1DSO,2 PDS? GUP1.1 10236000 BZ DSKOPN No, we just write over it GUP1.1 10237000 BAL 14,DSKVALS Yes, copy DCB info GUP1.1 10238000 BAL 9,DSKFABS GUP1.1 10239000 DSKOPN CNOP 0,4 @SC86299 10240000 BAL 2,DSKOPT Open and test @SC86299 10241000 OPEN (0,OUTPUT),MF=L @SC86299 10242000 DSKOPT CLI FABDSN,C'+' Just DDNAME? GUP1.1 10243000 BE DSKOPDZ Yes, don't need to allocate GUP1.1 10244000 KCALL DYNALC,DYNPL,EXT @SC86299 10245000 DSKOPDZ DS 0H GUP1.1 10246000 OPEN ((3)),MF=(E,(2)) @SC86299 10247000 TM FABOFLGS,X'10' @SC86299 10248000 BZ DSKER1 Didn't work @SC86299 10249000 B RTRN0 @SC86295 10250000 * 10251000 DSKTEST BCT 0,DSKCLOS @SC86295 10252000 B RTRN1 @SC86299 10253000 * 10254000 * Close file whose ticket is at (R1), release block 10255000 DSKCLOS BCT 0,DSKRED @SC86295 10256000 ICM 3,15,0(1) Get FAB ptr, if any @SC86295 10257000 BZ RTRN0 None, ignore @SC86295 10258000 XC 0(4,1),0(1) Yes, now clear ticket @SC86295 10259000 CLOSE ((3)) @SC86299 10260000 FREEPOOL (3) @SC86299 10261000 LA 0,FABDWDS @SC86295 10262000 LR 1,3 @SC86299 10263000 DMSFRET DWORDS=(0),LOC=(1) @SC86295 10264000 B RTRN0 @SC86295 10265000 * 10266000 * Read from file whose ticket is at (R1) 10267000 DSKRED SH 0,=H'4' 10268000 BCT 0,DSKWRT @SC86295 10269000 LTR 3,1 Get FAB ptr @SC86299 10270000 BNP RTRN1 Not defined anymore @SC86299 10271000 L 15,FABGET I/O routine @SC86299 10272000 BALR 14,15 Go to it @SC86299 10273000 LM 4,5,FDBBUFF Get buffer and size @SC86299 10274000 LH 7,FABLRECL Actual length @SC86299 10275000 AR 7,1 End of record @SC86299 10276000 BAL 2,DSKTV @SC86299 10277000 LA 1,4(1) Skip over SDW if V @SC86299 10278000 SR 7,1 Revised length @SC86299 10279000 LR 6,1 @SC86299 10280000 CR 7,5 @SC86299 10281000 BNL *+6 @SC86299 10282000 LR 5,7 Buffer not filled @SC86299 10283000 L 1,4(13) @SC86299 10284000 ST 5,20(1) Return length in R0 @SC86299 10285000 MVCL 4,6 Copy to buffer @SC86299 10286000 B RTRN0 @SC86299 10287000 * End of file on input. Don't close it yet. @SC86295 10288000 DSKEOD LA 15,12 End return code @SC86295 10289000 B RTRN @SC86295 10290000 * 10291000 * Write to file whose ticket is at (R1) 10292000 DSKWRT DS 0H 10293000 LTR 3,1 Get FAB ptr @SC86299 10294000 BNP RTRN1 Not defined anymore @SC86299 10295000 LM 4,5,FDBBUFF Get buffer and size @SC86299 10296000 LR 6,5 Copy for LRECL @SC86299 10297000 CH 6,FDBLRC @SC86299 10298000 BNH *+8 @SC86299 10299000 LH 6,FDBLRC Don't allow more than LRECL if V @SC86299 10300000 BAL 2,DSKTV @SC86299 10301000 LA 6,4(5) + 4 if RECFM=V @SC86299 10302000 STH 6,FABLRECL Set up for output @SC86299 10303000 L 15,FABGET I/O routine @SC86299 10304000 BALR 14,15 Do it @SC86299 10305000 XC 0(4,1),0(1) @SC86299 10306000 STCM 6,3,0(1) In case V @SC86299 10307000 BAL 2,DSKTV @SC86299 10308000 LA 1,4(1) V: space over SDW @SC86299 10309000 LR 6,1 @SC86299 10310000 LR 7,5 @SC86299 10311000 MVCL 6,4 Copy to output record @SC86299 10312000 B RTRN0 @SC86295 10313000 * 10314000 DSKTV TM FABRECFM,FABRECU @SC86299 10315000 BNM 4(2) U @SC86299 10316000 TM FABRECFM,FABRECF @SC86299 10317000 BO 4(2) F @SC86299 10318000 BR 2 V @SC86299 10319000 * Return on error, release useless block, if any 10320000 DSKER1 LTR 1,4 Any block assigned? @SC86295 10321000 BZ RTRN1 No @SC86295 10322000 LA 0,FABDWDS Yes, release it @SC86295 10323000 DMSFRET DWORDS=(0),LOC=(1) @SC86295 10324000 B RTRN1 Flag error @SC86295 10325000 * 10326000 DSKALC LR 5,1 Save FDB ptr @SC86295 10327000 LA 6,1 Update counter @SC86299 10328000 A 6,EVCTR @SC86299 10329000 ST 6,EVCTR @SC86299 10330000 LA 0,FABDWDS @SC86295 10331000 DMSFREE DWORDS=(0),ERR=DSKER1 @SC86295 10332000 LR 3,1 New block ptr @SC86295 10333000 LR 4,1 @SC86295 10334000 L 1,4(13) @SC86295 10335000 ST 3,20(1) Return R0 @SC86295 10336000 XC 0(8*FABDWDS,3),0(3) @SC86295 10337000 MVC FDBD(FDBCOP),0(5) Copy user's FDB @SC86295 10338000 MVC FABDSN,0(2) @SC86299 10339000 LR 15,2 Set up DSN ptr @SC86299 10340000 LA 0,FABDDNAM Get DDN ptr @SC86299 10341000 LA 1,FDBUNT Get UNIT ptr @SC86299 10342000 LA 2,FDBVOL Get VOL ptr @SC86299 10343000 STM 15,2,DYNPL Set up DYNALC @SC86299 10344000 MVI FABBUFCB+3,1 Fill out DCB @SC86299 10345000 MVI FABDSORG,X'40' =PS @SC86299 10346000 MVI FABIOBAD+3,1 @SC86299 10347000 LA 0,DSKEOD @SC86299 10348000 LA 1,DSKOPEX @SC86299 10349000 STM 0,1,FABEODAD @SC86299 10350000 UNPK FABDDNAM,EVCTR(5) @SC86299 10351000 TR FABDDNAM,TRHEX Get unique DDNAME @SC86299 10352000 MVI FABDDNAM,C'K' @SC86299 10353000 MVI FABDDNAM+7,C'Z' @SC86299 10354000 MVC FABOFLGS(4),=X'02,00,48,48' @SC86299 10355000 MVI FABCHECK+3,1 @SC86299 10356000 LA 1,RTRN1 @SC86299 10357000 ST 1,FABSYNAD In case of error @SC86299 10358000 MVI FABIOBA+3,1 @SC86299 10359000 MVI FABEOBAD+3,1 GUP1.1 10360000 MVI FABRECAD+3,1 GUP1.1 10361000 MVI FABCNTRL+3,1 GUP1.1 10362000 MVI FABEOB+3,1 @SC86299 10363000 DSKFABS LH 1,FDBLRC Copy Info to DCB @SC86299 10364000 CLI FABDSN,C'+' Just DDNAME? GUP1.1 10365000 BE DSKDDA Yes, copy it to FAB GUP1.1 10366000 STH 1,FABLRECL @SC86299 10367000 MVC FABBLKSI,FDBBLKSI @SC86299 10368000 MVI FABRECFM,FABRECU @SC86299 10369000 CLI FDBRCF,C'U' @SC86299 10370000 BER 9 @SC86299 10371000 MVI FABRECFM,FABRECF+FABRECBR @SC86299 10372000 CLI FDBRCF,C'F' @SC86299 10373000 BER 9 @SC86299 10374000 MVI FABRECFM,FABRECV+FABRECBR @SC86299 10375000 LA 1,4(1) Allow for RDW @SC86299 10376000 STH 1,FABLRECL @SC86299 10377000 BR 9 @SC86299 10378000 DSKDDA MVC FABDDNAM,FABDSN+1 Copy to DDNAME GUP1.1 10379000 BR 9 GUP1.1 10380000 * 10381000 * Call with R15->name, return to R2 with CC set (Z if ok) 10382000 DSKLKP SR 0,0 @SC86299 10383000 CLI 0(15),C'+' Just DDNAME? GUP1.1 10384000 BER 2 Yes, say we found it GUP1.1 10385000 LA 1,CAMVOLS @SC86299 10386000 LA 14,X'44' Name code @SC86299 10387000 SLL 14,24 @SC86299 10388000 STM 14,1,CAMLOC Save dsn ptr, etc @SC86299 10389000 LA 0,CAMVOLS+6 @SC86299 10390000 LA 1,CAMDSCB @SC86299 10391000 LA 14,X'C1' Search code @SC86299 10392000 SLL 14,24 @SC86299 10393000 STM 14,1,CAMOBT @SC86299 10394000 LOCATE CAMLOC @SC86299 10395000 LTR 6,15 Retain 1st code in R6 @SC86299 10396000 BNZR 2 Give up @SC86299 10397000 OBTAIN CAMOBT Get DSCB @SC86299 10398000 LTR 15,15 Test return code @SC86299 10399000 BR 2 @SC86295 10400000 * 10401000 DSKVALS LA 0,FDBD Ptr to FDB @SC86295 10402000 L 1,4(13) @SC86295 10403000 ST 0,24(1) Return ptr to caller @SC86295 10404000 CLI FABDSN,C'+' Just DDNAME? GUP1.1 10405000 BER 14 Yes, done: no DSCB GUP1.1 10406000 MVC FDBBLKSI,DS1BLK @SC86299 10407000 MVC FDBVOL,DS1VOL Copy volume name @SC86299 10408000 LH 1,DS1BLK Use BLKSIZE if 'U' @SC86299 10409000 MVI FDBRCF,C'U' @SC86299 10410000 TM DS1RCF,FABRECU @SC86299 10411000 BO DSKVLR @SC86299 10412000 LH 1,DS1LRC Use LRECL if 'F' @SC86299 10413000 MVI FDBRCF,C'F' @SC86299 10414000 TM DS1RCF,FABRECF @SC86299 10415000 BO DSKVLR @SC86299 10416000 MVI FDBRCF,C'V' @SC86299 10417000 S 1,F4 Use LRECL-4 if 'V' @SC86299 10418000 DSKVLR STH 1,FDBLRC @SC86299 10419000 BR 14 @SC86299 10420000 * 10421000 DSKOPEX DC 0F'0',X'85',AL3(DSKOPC) OPEN EXIT @SC86299 10422000 * 10423000 DSKOPC LR 3,1 @SC86299 10424000 LH 5,FABBLKSI @SC86299 10425000 LTR 5,5 @SC86299 10426000 BP *+8 @SC86299 10427000 LH 5,=H'6233' @SC86299 10428000 LR 6,5 @SC86299 10429000 TM FABRECFM,FABRECU @SC86299 10430000 BO DSKOPS @SC86299 10431000 LH 6,FABLRECL @SC86299 10432000 BNZ *+8 @SC86299 10433000 OI FABRECFM,FABRECF+FABRECBR @SC86299 10434000 LTR 6,6 @SC86299 10435000 BP DSKOPQ @SC86299 10436000 LA 6,80 @SC86299 10437000 BAL 2,DSKTV @SC88049 10438000 LA 6,4(6) Allow LRECL=84 for VB @SC88049 10439000 DSKOPQ TM FABRECFM,FABRECF @SC86299 10440000 BZ DSKOPV @SC86299 10441000 SR 4,4 @SC86299 10442000 DR 4,6 @SC86299 10443000 LTR 5,5 @SC88104 10444000 BP *+8 @SC88104 10445000 LA 5,1 BLKSIZE was less than LRECL! @SC88104 10446000 MR 4,6 @SC86299 10447000 B DSKOPS @SC86299 10448000 DSKOPV LA 4,4(6) @SC86299 10449000 CR 4,5 @SC86299 10450000 BNH DSKOPS @SC86299 10451000 LR 5,4 @SC86299 10452000 DSKOPS STH 6,FABLRECL @SC86299 10453000 STH 5,FABBLKSI @SC86299 10454000 BR 14 @SC86299 10455000 * 10456000 LOCALS , @SC86295 10457000 EXIT 10458000